Exercicício 02

Instalando as bibliotecas

pacotes <- c("plotly","tidyverse","knitr","kableExtra","car","rgl","gridExtra",
             "PerformanceAnalytics","reshape2","rayshader","psych","ggrepel",
             "factoextra","sp","tmap","magick","gridExtra")

if(sum(as.numeric(!pacotes %in% installed.packages())) != 0){
  instalador <- pacotes[!pacotes %in% installed.packages()]
  for(i in 1:length(instalador)) {
    install.packages(instalador, dependencies = T)
    break()}
  sapply(pacotes, require, character = T) 
} else {
  sapply(pacotes, require, character = T) 
}
##               plotly            tidyverse                knitr 
##                 TRUE                 TRUE                 TRUE 
##           kableExtra                  car                  rgl 
##                 TRUE                 TRUE                 TRUE 
##            gridExtra PerformanceAnalytics             reshape2 
##                 TRUE                 TRUE                 TRUE 
##            rayshader                psych              ggrepel 
##                 TRUE                 TRUE                 TRUE 
##           factoextra                   sp                 tmap 
##                 TRUE                 TRUE                 TRUE 
##               magick            gridExtra 
##                 TRUE                 TRUE

Proposta de estudo de validação de constructos

load("percepcao_lojas.RData")

Questionário proposto

questionario <- image_read("questionário.png")
plot(questionario)

Apresentando a base de dados:

percepcao_lojas 
## # A tibble: 1,400 x 8
##    sortimento reposição layout conforto limpeza atendimento preço desconto
##         <dbl>     <dbl>  <dbl>    <dbl>   <dbl>       <dbl> <dbl>    <dbl>
##  1      10         6.88   5.48     6.60    5.73       2.05   1.58     2.76
##  2       6.05      4.76   6.44     6.44    6.09       1.17   4.43     6.23
##  3       5.45      4.65   5.34     6.16    5.72       2.34   4.10     5.38
##  4       6.09      5.03   6.25     5.96    5.56       2.34   3.61     5.01
##  5       5.44      4.85   5.14     6.30    5.98       0.287  3.64     4.68
##  6       5.27      4.55   5.08     6.16    5.27       1.02   4.25     5.65
##  7       7.31      5.28   8.43     8.37    7.99       1.61   5.39     6.50
##  8       5.97      4.50   6.54     6.02    5.08       1.90   4.48     6.10
##  9       5.70      4.76   5.74     6.33    5.89       0.873  4.40     6.20
## 10       6.36      5.06   6.76     6.16    6.03       2.19   4.39     6.11
## # … with 1,390 more rows

Analisando as correlações entre variáveis da base de dados percepcao_lojas

chart.Correlation(percepcao_lojas, histogram = TRUE)

Salvando a Matriz de Correlações

rho_lojas <- cor(percepcao_lojas)

Construindo um mapa de calor a partir das correlações

plot2d_rho_lojas <-rho_lojas %>% 
  melt() %>% 
  ggplot() +
  geom_tile(aes(x = Var1, y = Var2, fill = value)) +
  geom_text(aes(x = Var1, y = Var2, label = round(x = value, digits = 3)),
            size = 4) +
  labs(x = NULL,
       y = NULL,
       fill = "Correlações") +
  scale_fill_gradient2(low = "dodgerblue4", 
                       mid = "white", 
                       high = "brown4",
                       midpoint = 0) +
  theme(panel.background = element_rect("white"),
        panel.grid = element_line("grey95"),
        panel.border = element_rect(NA),
        legend.position = "bottom",
        axis.text.x = element_text(angle = 0))

plot2d_rho_lojas

Visualizando o plot 3D

O teste de efericidade de Bartlett

cortest.bartlett(R = rho_lojas)
## Warning in cortest.bartlett(R = rho_lojas): n not specified, 100 used
## $chisq
## [1] 941.172
## 
## $p.value
## [1] 3.883815e-180
## 
## $df
## [1] 28

O algoritmo prcomp(), do pacote psych, EXIGE que a a matriz de dados fornecida a ele já esteja padronizada pelo procedimento zscores:

percepcao_lojas_std <- percepcao_lojas %>% 
  scale() %>% 
  data.frame()

Rodando a PCA

afpc_lojas <- prcomp(percepcao_lojas_std)
summary(afpc_lojas)
## Importance of components:
##                           PC1    PC2    PC3     PC4     PC5    PC6     PC7
## Standard deviation     1.9558 1.5013 0.9713 0.77243 0.46291 0.3544 0.15827
## Proportion of Variance 0.4781 0.2817 0.1179 0.07458 0.02679 0.0157 0.00313
## Cumulative Proportion  0.4781 0.7599 0.8778 0.95238 0.97917 0.9949 0.99799
##                            PC8
## Standard deviation     0.12665
## Proportion of Variance 0.00201
## Cumulative Proportion  1.00000

Sumarizando pontos importantes:

data.frame(eigenvalue = afpc_lojas$sdev ^ 2,
           var_compartilhada = summary(afpc_lojas)$importance[2,],
           var_cumulativa = summary(afpc_lojas)$importance[3,]) -> relatorio_lojas

relatorio_lojas
##     eigenvalue var_compartilhada var_cumulativa
## PC1 3.82498900           0.47812        0.47812
## PC2 2.25391334           0.28174        0.75986
## PC3 0.94350507           0.11794        0.87780
## PC4 0.59664723           0.07458        0.95238
## PC5 0.21428491           0.02679        0.97917
## PC6 0.12556987           0.01570        0.99486
## PC7 0.02504948           0.00313        0.99799
## PC8 0.01604110           0.00201        1.00000

Visualizando os pesos que cada variável tem em cada componente principal obtido pela PCA

ggplotly(
  data.frame(afpc_lojas$rotation) %>%
    mutate(var = names(percepcao_lojas)) %>%
    melt(id.vars = "var") %>%
    mutate(var = factor(var)) %>%
    ggplot(aes(x = var, y = value, fill = var)) +
    geom_bar(stat = "identity", color = "black") +
    facet_wrap(~variable) +
    labs(x = NULL, y = NULL, fill = "Legenda:") +
    scale_fill_viridis_d() +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90))
)

Extraindo as Cargas Fatoriais

k <- sum((afpc_lojas$sdev ^ 2) > 1) 
cargas_fatoriais <- afpc_lojas$rotation[, 1:k] %*% diag(afpc_lojas$sdev[1:k])

Visualizando as cargas fatoriais

data.frame(cargas_fatoriais) %>%
  rename(F1 = X1,
         F2 = X2) 
##                     F1          F2
## sortimento  -0.9179228  0.17358884
## reposição   -0.6921685  0.65956728
## layout      -0.8552432 -0.18455871
## conforto    -0.9090551  0.02924618
## limpeza     -0.8488383  0.01020367
## atendimento -0.3105135 -0.06475223
## preço       -0.2736408 -0.95034455
## desconto    -0.2316529 -0.91999037

Visualizando as Comunalidades

data.frame(rowSums(cargas_fatoriais ^ 2)) %>%
  rename(comunalidades = 1) 
##             comunalidades
## sortimento      0.8727153
## reposição       0.9141263
## layout          0.7655028
## conforto        0.8272365
## limpeza         0.7206306
## atendimento     0.1006115
## preço           0.9780340
## desconto        0.9000454

Relatório das cargas fatoriais e das comunalidades

data.frame(cargas_fatoriais) %>%
  rename(F1 = X1,
         F2 = X2) %>%
  mutate(Comunalidades = rowSums(cargas_fatoriais ^ 2)) 
##                     F1          F2 Comunalidades
## sortimento  -0.9179228  0.17358884     0.8727153
## reposição   -0.6921685  0.65956728     0.9141263
## layout      -0.8552432 -0.18455871     0.7655028
## conforto    -0.9090551  0.02924618     0.8272365
## limpeza     -0.8488383  0.01020367     0.7206306
## atendimento -0.3105135 -0.06475223     0.1006115
## preço       -0.2736408 -0.95034455     0.9780340
## desconto    -0.2316529 -0.91999037     0.9000454

Note que, tanto as cargas fatoriais quanto a comunalidade da variável atendimento são relativamente baixas. Tal situação pode evidenciar a necessidade da extração de um terceiro fator, descaracterizando o critério da raiz latente:

Extraindo as Cargas Fatoriais para os 3 Fatores

k <- length(afpc_lojas$sdev[1:3])
cargas_fatoriais <- afpc_lojas$rotation[, 1:k] %*% diag(afpc_lojas$sdev[1:k])

Visualizando as cargas fatoriais

data.frame(cargas_fatoriais) %>%
  rename(F1 = X1,
         F2 = X2,
         F3 = X3)
##                     F1          F2           F3
## sortimento  -0.9179228  0.17358884  0.119311288
## reposição   -0.6921685  0.65956728 -0.050840580
## layout      -0.8552432 -0.18455871  0.195862787
## conforto    -0.9090551  0.02924618  0.021148058
## limpeza     -0.8488383  0.01020367  0.032634707
## atendimento -0.3105135 -0.06475223 -0.941641098
## preço       -0.2736408 -0.95034455  0.010633819
## desconto    -0.2316529 -0.91999037  0.003096998

Visualizando as Comunalidades

data.frame(rowSums(cargas_fatoriais ^ 2)) %>%
  rename(comunalidades = 1)
##             comunalidades
## sortimento      0.8869505
## reposição       0.9167110
## layout          0.8038651
## conforto        0.8276837
## limpeza         0.7216956
## atendimento     0.9872994
## preço           0.9781471
## desconto        0.9000550

Relatório das cargas fatoriais e das comunalidades

data.frame(cargas_fatoriais) %>%
  rename(F1 = X1,
         F2 = X2,
         F3 = X3) %>%
  mutate(Comunalidades = rowSums(cargas_fatoriais ^ 2)) 
##                     F1          F2           F3 Comunalidades
## sortimento  -0.9179228  0.17358884  0.119311288     0.8869505
## reposição   -0.6921685  0.65956728 -0.050840580     0.9167110
## layout      -0.8552432 -0.18455871  0.195862787     0.8038651
## conforto    -0.9090551  0.02924618  0.021148058     0.8276837
## limpeza     -0.8488383  0.01020367  0.032634707     0.7216956
## atendimento -0.3105135 -0.06475223 -0.941641098     0.9872994
## preço       -0.2736408 -0.95034455  0.010633819     0.9781471
## desconto    -0.2316529 -0.91999037  0.003096998     0.9000550

Note que a decisão de extração de três fatores, em detrimento da extração com base no critério da raiz latente, aumenta as comunalidades das variáveis, com destaque para a variável atendimento, agora correlacionada mais fortemente com o terceiro fator.

Comportamento das cargas fatoriais de forma 2D (usando F1 e F2)

data.frame(cargas_fatoriais) %>%
  rename(F1 = X1,
         F2 = X2,
         F3 = X3) -> cargas_fatoriais

ATENÇÃO! OS SINAIS NEGATIVOS PARA A PLOTAGEM DE F2, SERVEM ÚNICA E EXCLUSIVAMENTE PARA INVERTER OS EIXOS DO GRÁFICO E PERMITIR A SUBSEQUENTE COMPARAÇÃO COM O PLOT 3D.

cargas_fatoriais %>% 
  ggplot(aes(x = -F2, y = F1)) +
  geom_point(color = "orange") +
  geom_hline(yintercept = 0, color = "darkorchid") +
  geom_vline(xintercept = 0, color = "darkorchid") +
  geom_text_repel(label = row.names(cargas_fatoriais)) +
  theme_bw() 

Comportamento das cargas fatoriais de forma 3D (usando F1, F2 e F3)

afpc_lojas_3D <- plot_ly()

afpc_lojas_3D <- add_trace(p = afpc_lojas_3D, 
                         x = cargas_fatoriais$F2, 
                         y = cargas_fatoriais$F3, 
                         z = cargas_fatoriais$F1,
                         mode = 'text', 
                         text = rownames(cargas_fatoriais),
                         textfont = list(color = "orange"), 
                         showlegend = FALSE)

afpc_lojas_3D <- layout(p = afpc_lojas_3D,
                        scene = list(xaxis = list(title = colnames(cargas_fatoriais)[2]),
                                     yaxis = list(title = colnames(cargas_fatoriais)[3]),
                                     zaxis = list(title = colnames(cargas_fatoriais)[1]),
                                     aspectmode = "data"))

afpc_lojas_3D
## No trace type specified:
##   Based on info supplied, a 'scatter3d' trace seems appropriate.
##   Read more about this trace type -> https://plotly.com/r/reference/#scatter3d